home *** CD-ROM | disk | FTP | other *** search
/ Hottest 5 / Hottest 5 (1995)(PDSoft)[!].iso / pdsoft / library / lha / board2.lha / Solitaire / init.bas
BASIC Source File  |  1980-01-10  |  14KB  |  337 lines
  1. 10    '******************************************************************
  2. 20    '**                                                              **
  3. 30    '**  MKSoft Solitaire -- Copyright (c) 1985 by Michael Sinz      **
  4. 40    '**                                                              **
  5. 50    '**  For the Amiga 1000 computer system, under ABasiC v1.0       **
  6. 60    '**                                                              **
  7. 70    '******************************************************************
  8. 80    '**                                                              **
  9. 81    '**  Placed in the public domain.  Please do not try to sell     **
  10. 82    '**  this program in any way.  It should be freely copied by     **
  11. 83    '**  anyone wishing to have it.                                  **
  12. 84    '**                                                              **
  13. 85    '**  Please send any modifications to:  MKSoft                   **
  14. 86    '**                                     2818 Red Fox Trail       **
  15. 87    '**                                     Troy, MI   48098         **
  16. 88    '**                                                              **
  17. 89    '******************************************************************
  18. 90    '
  19. 100   ' The .MAIN. part of the program is farther on down in the code.
  20. 110   ' Subroutines come first.  (Just happens to be my style.)
  21. 120   Goto 1780
  22. 130   '
  23. 140   '
  24. 150   ' Routine that sets the pointer to the color designated by R% G% B%
  25. 160   For X%=17 To 19:RGB X%,R%,G%,B%:Next X%:Return
  26. 170   '
  27. 180   '
  28. 190   ' This is the color of the arrow if the left button is pressed.
  29. 200   ' It will be one of two colors, one when in the playing field of the
  30. 210   ' window, the other when in the selection box of the window.
  31. 220   R%=13:G%=0:B%=7-8*(MX%<535 And MY%>176):Goto 160
  32. 230   '
  33. 240   '
  34. 250   ' This is the color of the arrow when no mouse button is pressed.
  35. 260   ' It will be one of three colors, one if on the playing field, one
  36. 270   ' if in the selection box, and one if the player has picked up some
  37. 280   ' cards and has not yet put them down.
  38. 290   R%=3*Empty%:G%=7*Empty%:B%=-15*(MX%<535 And MY%>176):Goto 160
  39. 300   '
  40. 310   '
  41. 320   ' Finds the position of the arrow and the status of the buttons.
  42. 330   Randomize:Ask Mouse MX%,MY%,MB%:If MB%=4 Then 220 Else 290
  43. 340   '
  44. 350   '
  45. 360   ' This routine calculates the position of the card that it was asked
  46. 370   ' to display and then goes to the correct routine so that it can
  47. 380   ' draw that card.
  48. 390   ' Once a card is drawn, the image is stored in an array so that it
  49. 400   ' can be displayed quickly. SF1%, SF2%, SF3%, and SF4% variables
  50. 410   ' are flags that signal if that card has been drawn yet.
  51. 420   CX%=X%*77+1:CY%=Y%*12+1:On Suit%+1 Goto 770,660,480,540,430,440
  52. 430   PenA 3:PenB 2:PenO 1:Pattern 2,Pat%:DrawMode 1:Goto 450
  53. 440   PenA 0:PenO 0
  54. 450   Box (CX%,CY%;CX%+69,CY%+35),1:Pattern 1,Full%:DrawMode 0:Return
  55. 460   PenA 1:PenO 1:Box (CX%,CY%;CX%+69,CY%+35),1
  56. 470   Draw (CX%,CY% To CX%+69,CY% To CX%+69,CY%+35),3:Return
  57. 480   If SF1% Then 520
  58. 490   Gosub 460:PenA 2
  59. 500   Area(CX%+35,CY%+3 To CX%+4,CY%+18 To CX%+35,CY%+33 To CX%+65,CY%+18)
  60. 510   SShape (CX%,CY%;CX%+70,CY%+36),S1%:SF1%=1
  61. 520   GShape (CX%,CY%),S1%
  62. 530   PenA 2:Goto 880
  63. 540   If SF2% Then 640
  64. 550   Gosub 460:PenA 3:PenO 3
  65. 560   Circle (CX%+21,CY%+18),4,1.1:Draw (CX%+26,CY%+15 To CX%+33,CY%+17)
  66. 570   Draw (To CX%+29,CY%+13):Circle (CX%+49,CY%+18),4,1.1
  67. 580   Circle (CX%+35,CY%+10),4,1.1:Draw (CX%+43,CY%+15 To CX%+37,CY%+17)
  68. 590   Draw (To CX%+41,CY%+13):Draw (CX%+26,CY%+21 To CX%+33,CY%+19)
  69. 600   Draw (To CX%+25,CY%+29 To CX%+45,CY%+29 To CX%+37,CY%+19)
  70. 610   Draw (To CX%+43,CY%+21):Paint (CX%+35,CY%+27)
  71. 620   Paint (CX%+21,CY%+18):Paint (CX%+49,CY%+18):Paint (CX%+35,CY%+10)
  72. 630   SShape (CX%,CY%;CX%+70,CY%+36),S2%:SF2%=1
  73. 640   GShape (CX%,CY%),S2%
  74. 650   PenA 3:Goto 880
  75. 660   If SF3% Then 750
  76. 670   Gosub 460:PenA 3:PenO 3
  77. 680   Draw (CX%+13,CY%+19 To CX%+34,CY%+4 To CX%+55,CY%+19)
  78. 690   Circle (CX%+20,CY%+23),6,0.84:Circle (CX%+48,CY%+23),6,0.84
  79. 700   Draw (CX%+32,CY%+23 To CX%+26,CY%+33 To CX%+42,CY%+33)
  80. 710   Draw (To CX%+36,CY%+23)
  81. 720   Paint (CX%+34,CY%+6):Paint (CX%+20,CY%+23):Paint (CX%+48,CY%+23)
  82. 730   DrawMode 1:PenB 3:PenA 2:Print AT (CX%+23,CY%+23) "MKS";
  83. 740   SShape (CX%,CY%;CX%+70,CY%+36),S3%:SF3%=1
  84. 750   GShape (CX%,CY%),S3%
  85. 760   PenA 3:Goto 880
  86. 770   If SF4% Then 830
  87. 780   Gosub 460:PenA 2:PenO 2
  88. 790   Draw (CX%+13,CY%+14 To CX%+36,CY%+31 To CX%+59,CY%+14)
  89. 800   Circle (CX%+23,CY%+12),6:Circle (CX%+48,CY%+12),6
  90. 810   Paint (CX%+36,CY%+20):Paint (CX%+24,CY%+12):Paint (CX%+48,CY%+12)
  91. 820   SShape (CX%,CY%;CX%+70,CY%+36),S4%:SF4%=1
  92. 830   GShape (CX%,CY%),S4%
  93. 840   PenA 2
  94. 850   '
  95. 860   '
  96. 870   ' Display the character of the card's value.
  97. 880   DrawMode 1:PenB 1
  98. 890   Print AT (CX%+2,CY%+8) Mid$("A23456789TJQK-",Value%,1);
  99. 900   DrawMode 0:Return
  100. 910   '
  101. 920   '
  102. 930   ' Figure out what the card is and then call the display routine.
  103. 940   Gosub 980:Goto 420
  104. 950   '
  105. 960   '
  106. 970   ' Figure out the suit and value of the card.
  107. 980   Suit%=(DisplayCard% And 48)/16:Value%=DisplayCard% And 15:Return
  108. 990   '
  109. 1000  '
  110. 1010  ' This routine handles the NEXT CARD selection.  It flashes the
  111. 1020  ' NEXT CARD selector to indicate that it was selected.  If there
  112. 1030  ' are no more cards left, it turns the selector OFF.
  113. 1040  DrawMode 1:PenA 2:PenB 3:Print AT (440,184) " NEXT CARD ";
  114. 1050  If Index%>51 Or Empty%=0 Then 1080
  115. 1060  Discard%(Index%(7))=Deck%(Index%):Index%=Index%+1:X%=7:Y%=12
  116. 1070  DisplayCard%=Deck%(Index%-1):Gosub 940:Index%(7)=Index%(7)+1
  117. 1080  If Index%>51 Then 1100
  118. 1090  PenA 1:PenB 2:DrawMode 1:Print AT (440,184) " NEXT CARD ";
  119. 1100  DrawMode 0
  120. 1110  Return
  121. 1120  '
  122. 1130  '
  123. 1140  ' Pick up card routine.
  124. 1150  If Index%(Cursor%)=0 Then Return
  125. 1160  Store%=Cursor%
  126. 1170  Empty%=0:X%=Cursor%:Suit%=4
  127. 1180  If Cursor%=7 Then Y%=12:Goto 420
  128. 1190  Suit%=5:For Y%=Index%(Cursor%)-1 To 1 Step -3:Gosub 420:Next Y%:Y%=0
  129. 1200  Suit%=4-(Pile%(Cursor%,0)=0)
  130. 1210  Goto 420
  131. 1220  '
  132. 1230  '
  133. 1240  ' If error, just set cursor to original pickup area.
  134. 1250  Cursor%=Store%
  135. 1260  '
  136. 1270  '
  137. 1280  ' This is the drop card routine.  If the user tries to drop the
  138. 1290  ' card(s) on an illegal area, the routine will just drop the cards
  139. 1300  ' back where they came from.  (See line above.)
  140. 1310  If Cursor%=7 Then 1510
  141. 1320  If Store%=Cursor% Then 1640
  142. 1330  If Index%(Cursor%)=0 Then 1530
  143. 1340  DisplayCard%=Cards%(Cursor%,Index%(Cursor%)-1):Gosub 980
  144. 1350  TempSuit%=Suit%:TempValue%=Value%
  145. 1360  If Store%=7 Then DisplayCard%=Discard%(Index%(7)-1):Goto 1380
  146. 1370  DisplayCard%=Cards%(Store%,0)
  147. 1380  Gosub 980:If (Suit% And 1)=(TempSuit% And 1) Then 1250
  148. 1390  If TempValue% <> Value%+1 Then 1250
  149. 1400  If Value%=1 Then 1250
  150. 1410  If Store%=7 Then 1580
  151. 1420  For I%=0 To Index%(Store%)-1:DisplayCard%=Cards%(Store%,I%)
  152. 1430  Y%=Index%(Cursor%):Cards%(Cursor%,Y%)=DisplayCard%:X%=Cursor%
  153. 1440  Gosub 940:Index%(Cursor%)=Y%+1:Cards%(Store%,I%)=0:Next I%
  154. 1450  Index%(Store%)=0:Empty%=1:If Pile%(Store%,0)=0 Then 1500
  155. 1460  DisplayCard%=Pile%(Store%,0):X%=Store%:Y%=0:Gosub 940
  156. 1470  Cards%(X%,0)=DisplayCard%:Index%(X%)=1
  157. 1480  For I%=0 To 4:Pile%(X%,I%)=Pile%(X%,I%+1):Next I%
  158. 1490  Pile%(X%,5)=0
  159. 1500  Return
  160. 1510  If Store%<>7 Then 1250
  161. 1520  DisplayCard%=Discard%(Index%(7)-1):X%=7:Y%=12:Empty%=1:Goto 940
  162. 1530  If Store%=7 Then DisplayCard%=Discard%(Index%(7)-1):Goto 1550
  163. 1540  DisplayCard%=Cards%(Store%,0)
  164. 1550  Gosub 980
  165. 1560  If Value%<>13 Then 1250
  166. 1570  If Store%<>7 Then 1420
  167. 1580  X%=Cursor%:Y%=Index%(X%):Cards%(X%,Y%)=DisplayCard%:Gosub 940
  168. 1590  Index%(X%)=Y%+1
  169. 1600  X%=7:Y%=12:Suit%=5:Index%(7)=Index%(7)-1:Empty%=1
  170. 1610  Discard%(Index%(7))=0
  171. 1620  If Index%(7)=0 Then 420
  172. 1630  DisplayCard%=Discard%(Index%(7)-1):Goto 940
  173. 1640  For I%=0 To Index%(Cursor%)-1:DisplayCard%=Cards%(Cursor%,I%)
  174. 1650  X%=Cursor%:Y%=I%:Gosub 940:Next I%:Empty%=1:Return
  175. 1660  '
  176. 1670  '
  177. 1680  '
  178. 1690  ' This is the start of the .MAIN. program.
  179. 1700  '
  180. 1710  ' We need 640 x 200 with 4 colors, so set up the screen.
  181. 1720  ' Color registers are:
  182. 1730  '
  183. 1740  ' RGB 0 = Green  --   0,  4,  0
  184. 1750  ' RGB 1 = White  --  12, 11, 10
  185. 1760  ' RGB 2 = Red    --  10,  0,  0
  186. 1770  ' RGB 3 = Black  --   0,  0,  0
  187. 1780  Screen 1,2:RGB 0,0,4,0:RGB 1,12,11,10:RGB 2,10,0,0:RGB 3,0,0,0
  188. 1790  '
  189. 1800  ' We need some arrays to store all of the important stuff.
  190. 1810  '
  191. 1820  ' S1%, S2%, S3%, S4% are graphic images of the four suits.
  192. 1830  '
  193. 1840  ' Pat% and Full% are flood-fill patterns.
  194. 1850  '
  195. 1860  ' Index%      - Stores the pointers to the stack sizes.
  196. 1870  ' Cards%      - Stores the UP card stacks.
  197. 1880  ' Pile%       - Stores the DOWN card stacks.
  198. 1890  ' Deck%       - Stores the DECK of cards.
  199. 1900  ' Discard%    - Stores the discarded pile.
  200. 1910  ' Foundation% - Stores the foundation information.
  201. 1920  Dim S1%(315),S2%(315),S3%(315),S4%(315),Pat%(1),Full%(0),Index%(7)
  202. 1930  Dim Cards%(6,11),Pile%(6,5),Deck%(51),Discard%(23),Foundation%(4)
  203. 1940  W$="--->>  MKSoft Solitaire    Copyright "+CHR$(169)+" 1985"
  204. 1950  Graphic (0):Print:Print " ";:Graphic (1):Empty%=1
  205. 1960  '
  206. 1970  ' Set up initial playing field.
  207. 1980  Pat%(0)=50115:Pat%(1)=15420:Full%(0)=65535
  208. 1990  For X%=0 To 6:Draw (74+X%*77,0 To 74+X%*77,200),1:Next X%
  209. 2000  W$=W$+"   by Michael Sinz  <<---"
  210. 2010  PenA 3:PenO 2:Box (1,176;536,187),1
  211. 2020  PenA 1:PenB 2:DrawMode 1
  212. 2030  Print AT ( 20,184) " QUIT ";
  213. 2040  Print AT (190,184) " PLAY AGAIN ";
  214. 2050  Print AT (440,184) " NEXT CARD ";
  215. 2060  Money=1000
  216. 2070  DrawMode 0
  217. 2080  '
  218. 2090  '
  219. 2100  ' Open the betting window.  This is Las Vegas Solitaire.  Buy the
  220. 2110  ' for some amount and get 1/10 back for each card on foundation.
  221. 2120  ' This means you could (if lucky) make 5.2 times your bet back.
  222. 2130  Window #1,0,0,640,200,W$
  223. 2140  Suit%=5:For X%=0 To 6:For Y%=2 To 11 Step 3:Gosub 420:Next Y%,X%
  224. 2150  Suit%=4:For X%=0 To 7:Y%=-12*(X%=7):Gosub 420:Next X%
  225. 2160  Value%=14:X%=7:For Suit%=0 To 3:Y%=Suit%*3:Gosub 420:Next Suit%
  226. 2170  CMD 1:Graphic (0):Empty%=0
  227. 2180  PenA 2:PenO 3
  228. 2190  Print:Print
  229. 2200  Print W$
  230. 2210  Print:Print "Point here and press LEFT mouse button.":Print
  231. 2220  Gosub 330:If MB%<>4 Then 2220
  232. 2230  If Bet=0 Then 2290
  233. 2240  Money=Money+Result:Print "You ";
  234. 2250  If Result<0 Then Print "lost";
  235. 2260  If Result>0 Then Print "won ";
  236. 2270  If Result=0 Then Print "broke even.":Goto 2290
  237. 2280  Print Using " $$#################,.##";ABS(Result)
  238. 2290  Print:If Money<0 Then Print "You owe "; Else Print "You have";
  239. 2300  Print Using " $$#################,.##";ABS(Money)
  240. 2310  Print
  241. 2320  Print "How much do you wish to bet?    (0 to end)"
  242. 2330  Input "Enter your bet: ";Bet:Bet=INT(Bet)
  243. 2340  If Bet=0 Then CMD 0:Close:Goto 3180
  244. 2350  If Bet<1 Then 2290
  245. 2360  Result=-Bet
  246. 2370  Bet=Bet/10
  247. 2380  Print "Each up card will be worth $";Bet
  248. 2390  Print "Shuffle...":Randomize
  249. 2400  For X%=0 To 51:Deck%(X%)=0:Next X%
  250. 2410  For X%=0 To 6:For Y%=0 To 5:Pile%(X%,Y%)=0:Next Y%
  251. 2420  For Y%=0 To 11:Cards%(X%,Y%)=0:Next Y%,X%
  252. 2430  For X%=0 To 3:Foundation%(X%)=0:Next X%
  253. 2440  For X%=0 To 48 Step 16:For Y%=1 To 13
  254. 2450  Z%=INT(52*RND):If Deck%(Z%)>0 Then 2450
  255. 2460  Deck%(Z%)=X%+Y%:Next Y%,X%
  256. 2470  Index%=0:For X%=1 To 6:For Y%=0 To X%-1:Pile%(X%,Y%)=Deck%(Index%)
  257. 2480  Index%=Index%+1:Next Y%,X%:CMD 0:Graphic (1)
  258. 2490  For X%=0 To 6:Cards%(X%,0)=Deck%(Index%):Index%=Index%+1
  259. 2500  Index%(X%)=1:Y%=0:DisplayCard%=Cards%(X%,0):Gosub 940:Next X%
  260. 2510  Index%(7)=0
  261. 2520  Close:Empty%=1:Gosub 330
  262. 2530  ' Betting window is closed, so lets play...
  263. 2540  Gosub 1040
  264. 2550  '
  265. 2560  '
  266. 2570  ' Keep checking the mouse until the button is pressed.
  267. 2580  Gosub 330:If MB%<>4 Then 2580
  268. 2590  '
  269. 2600  '
  270. 2610  ' Wait until the player lets go of the button.
  271. 2620  ' When s/he does, that is the place to check for the function.
  272. 2630  Gosub 330:If MB%=4 Then 2630
  273. 2640  '
  274. 2650  '
  275. 2660  ' Check if the arrow could be inside the function box.
  276. 2670  If MY%<177 Then 2790
  277. 2680  ' Is it in the QUIT box?
  278. 2690  If MX%>17 And MX%<66 Then 3180
  279. 2700  ' Is it in the PLAY AGAIN box?
  280. 2710  If MX%>187 And MX%<284 Then 2130
  281. 2720  ' Is it in the NEXT CARD box and is the function ON?
  282. 2730  If Empty% And Index%<52 And MX%>437 And MX%<526 Then 2540
  283. 2740  If MX%<539 Then 2580
  284. 2750  '
  285. 2760  '
  286. 2770  ' It is none of the option boxes, so lets see which column the
  287. 2780  ' player wants.  Also check if the player stayed on the field.
  288. 2790  Cursor%=INT(MX%/77)
  289. 2800  If Cursor%<0 Or Cursor%>7 Then 2580
  290. 2810  If Cursor%=7 Then 2920
  291. 2820  '
  292. 2830  '
  293. 2840  ' If it is one of the card piles, check if the player has some in
  294. 2850  ' his hand.  If not, pick that pile up otherwise drop the cards in
  295. 2860  ' the player's hand onto that pile.
  296. 2870  If Empty% Then Gosub 1150:Goto 2580
  297. 2880  Gosub 1310:Goto 2580
  298. 2890  '
  299. 2900  '
  300. 2910  ' Check if the player is pointing to the DECK pile.
  301. 2920  If MY%>144 Then 2870
  302. 2930  '
  303. 2940  '
  304. 2950  ' If not, the player is pointing to a foundation pile.  Try to
  305. 2960  ' put a card on the foundation if his hands are empty.
  306. 2970  If Empty%=0 Then 2580
  307. 2980  MatchSuit%=INT(MY%/36):Cursor%=-1
  308. 2990  For X%=0 To 7:If Index%(X%)=0 Then 3060
  309. 3000  If X%=7 Then DisplayCard%=Discard%(Index%(X%)-1):Goto 3020
  310. 3010  DisplayCard%=Cards%(X%,Index%(X%)-1)
  311. 3020  Gosub 980
  312. 3030  If MatchSuit%<>Suit% Then 3060
  313. 3040  If Foundation%(Suit%)<>Value%-1 Then 3060
  314. 3050  Cursor%=X%
  315. 3060  Next X%:If Cursor%<0 Then 2580
  316. 3070  Result=Result+Bet
  317. 3080  Suit%=MatchSuit%:X%=7:Y%=Suit%*3:Value%=Foundation%(Suit%)+1
  318. 3090  Foundation%(Suit%)=Value%:Gosub 420
  319. 3100  If Cursor%=7 Then Gosub 1600:Goto 2580
  320. 3110  X%=Cursor%:Y%=Index%(X%):Y%=Y%-1:Cards%(X%,Y%)=0
  321. 3120  Suit%=5:Gosub 420:Index%(X%)=Y%
  322. 3130  If Y%=0 Then Store%=X%:Gosub 1450:Goto 2580
  323. 3140  Y%=Y%-1:DisplayCard%=Cards%(X%,Y%):Gosub 940:Goto 2580
  324. 3150  '
  325. 3160  '
  326. 3170  ' Reset screen and colors so that things look good.
  327. 3180  ScnClr:Graphic (0):RGB 0,0,0,0:RGB 1,7,8,0:RGB 3,0,0,12
  328. 3190  Print "You ended up ";
  329. 3200  If Money<0 Then Print "owing"; Else Print "with";
  330. 3210  Print Using " $$#################,.##";ABS(Money);
  331. 3220  Print ".  You Started with $1,000.00"
  332. 3230  Print
  333. 3240  Print "Thank you for playing MKSoft Solitaire."
  334. 3250  print
  335. 3260  chdir "SYS:"
  336. 3270  chain "init.bas"
  337.